home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 24 / CU Amiga Magazine's Super CD-ROM 24 (1998)(EMAP Images)(GB)(Track 1 of 2)[!][issue 1998-07].iso / CUCD / Programming / SWI / source / lisp / qpfindpred.el < prev    next >
Encoding:
Text File  |  1992-05-26  |  9.3 KB  |  362 lines
  1. ;;;  SCCS: @(#)90/12/04 qpfindpred.el    2.3
  2. ;;;            Quintus Prolog - GNU Emacs Interface
  3. ;;;                         Support Functions
  4. ;;;
  5. ;;;                Consolidated by Sitaram Muralidhar
  6. ;;;
  7. ;;;                   sitaram@quintus.com
  8. ;;;              Quintus Computer Systems, Inc.
  9. ;;;                  2 May 1989       
  10. ;;;
  11. ;;; This file defines functions that support the Quintus Prolog - GNU Emacs
  12. ;;; interface.
  13. ;;;
  14. ;;;                   Acknowledgements
  15. ;;;
  16. ;;;
  17. ;;; This interface was made possible by contributions from Fernando
  18. ;;; Pereira and various customers of Quintus Computer Systems, Inc.,
  19. ;;; based on code for Quintus's Unipress Emacs interface.
  20. ;;; 
  21.  
  22. (defmacro error-occurred (&rest body)
  23.   (list 'condition-case nil (cons 'progn (append body '(nil))) '(error t)))
  24.  
  25. (defun find-pred ()
  26.   (interactive)
  27.   (let 
  28.       (term-start
  29.        term-type
  30.        target-functor
  31.        target-arity 
  32.        backward-predicate-beginning
  33.        backward-predicate-end 
  34.        (continue t)
  35.        (saw-first-clause (find-potential-clause)))
  36.  
  37.     (get-clause-info)
  38.     (setq target-functor *functor*)
  39.     (setq target-arity *arity*)
  40.  
  41.     (setq backward-predicate-end (mark))
  42.     (setq backward-predicate-beginning (dot))
  43.  
  44.     (previous-line 1)
  45.     (while (and continue
  46.                 (not saw-first-clause)
  47.                 (not (error-occurred
  48.                       (setq saw-first-clause (find-potential-clause))
  49.                       (get-clause-info)))
  50.                 )
  51.       (if (and (string-equal *functor* target-functor) 
  52.                (= *arity* target-arity))
  53.           (progn 
  54.             (setq backward-predicate-beginning (dot))
  55.             (previous-line 1))
  56.         (setq continue nil)
  57.         )
  58.       )
  59.  
  60.     (goto-char backward-predicate-end)
  61.     (setq continue t)
  62.     (while (and continue
  63.                 (not (error-occurred (get-clause-info)))
  64.                 )
  65.       (if (and (string-equal *functor* target-functor)
  66.                (= *arity* target-arity))
  67.           (progn 
  68.             (setq backward-predicate-end (mark))
  69.             (exchange-dot-and-mark))
  70.         (setq continue nil)))
  71.  
  72.     (goto-char backward-predicate-beginning)
  73.     (set-mark (point))
  74.     (goto-char backward-predicate-end)
  75.     )
  76.   )
  77.  
  78. (defun forward-to-clause-end  (term-start)
  79.   (let ((continue t)
  80.         (token-type (next-token)))
  81.     (while continue
  82.       (cond 
  83.        ((string-equal token-type "eof")
  84.         (goto-char term-start)
  85.         (BadFind "Can't find the end of this term"))
  86.         ((string-equal token-type "stop")
  87.         (setq continue nil))
  88.         (t (setq token-type (next-token)))
  89.         )
  90.       )
  91.     )
  92.   )
  93.  
  94. (defun forward-to-clause-end-heuristic (term-start)
  95.   (if (not (re-search-forward "[^-+*/\\^<>=`~:.?@#$&]\\.[\001- \177]" nil t))
  96.       (progn
  97.         (goto-char term-start)
  98.         (BadFind "Can't find the end of this term")
  99.         )
  100.     )
  101.   (while (within-comment)               ;  doesn't work with '%' style comments
  102.     (if (not (re-search-forward "[^-+*/\\^<>=`~:.?@#$&]\\.[\001- \177]" nil t))
  103.         (progn
  104.           (goto-char term-start)
  105.           (BadFind "Can't find the end of this term")
  106.           )
  107.       )
  108.     )
  109.   )
  110.  
  111.  
  112. (defun arity-overhead-for-grammar-rule  (term-start)
  113.   (let
  114.       ((token-type (next-token))
  115.        (token (region-to-string))
  116.        return)
  117.  
  118.     (cond 
  119.      ((string-equal token ":-")
  120.       (forward-to-clause-end term-start)
  121.       (setq return 0))
  122.      ((string-equal token-type "stop")
  123.       (setq return 0))
  124.      (t
  125.       (if (grammar-rule token-type token)
  126.           (progn 
  127.             (forward-to-clause-end term-start)
  128.             (setq return 2)
  129.             )
  130.         (progn 
  131.           (goto-char term-start)
  132.           (BadFind "Can't determine what type of clause this is")
  133.           )
  134.         )
  135.       )
  136.      )
  137.     return
  138.     )
  139.   )
  140.  
  141. (defun BadFind (message)
  142.   (sleep-for-millisecs 10)
  143.   (error message))
  144.  
  145. (defun grammar-rule  (mgr-token-type mgr-token)
  146.   (let (return
  147.         (continue t))
  148.     (while continue
  149.       (cond
  150.        ((string-equal mgr-token "-->")
  151.         (setq continue nil)
  152.         (setq return t))
  153.        ((or (string-equal mgr-token-type "stop")
  154.             (string-equal mgr-token-type "eof"))
  155.         (setq continue nil)
  156.         (setq return nil))
  157.         (t
  158.          (setq mgr-token-type (next-token))
  159.          (setq mgr-token (region-to-string))
  160.          )
  161.     )
  162.     )
  163.     return
  164. ))
  165.  
  166. ; 
  167. ; The following code finds the first line less than or equal to the current
  168. ;    line which has a non-layout character in the first column or the
  169. ;    first column does not start a comment ('%' or '/*'), end a comment
  170. ;    ('*/'), or is within a comment.
  171. ;
  172.  
  173. (defun find-potential-clause ()
  174.   (let
  175.       ((continue t)
  176.        (original-dot (dot))
  177.        char 
  178.        (return))
  179.     (while continue
  180.       (beginning-of-line)
  181.       (setq char (following-char))
  182.       (if (or 
  183.            (or (and (>= char ?\001) (<= char ?  )) (= char ?\177))  ; layout
  184.            (looking-at "%\\|/\\*\\|\\*/")  ; '%' or '/*' or '*/'
  185.            (within-comment)
  186.            (eobp)
  187.            )
  188.           (if (bobp)
  189.               (progn 
  190.                 (goto-char original-dot)
  191.                 (BadFind "Cannot find a valid line to start the procedure, command or query")
  192.                 )
  193.             (previous-line 1)
  194.             )
  195.         (progn 
  196.           (if (bobp)
  197.               (setq return t)
  198.            )
  199.            (setq continue nil)
  200.        )
  201.     )
  202.     )
  203.     return
  204. ))
  205.  
  206. (defun get-clause-info ()
  207.   (let ((term-start (dot))
  208.         (token-type (next-token))
  209.         (token (region-to-string)))
  210.     (cond 
  211.      ((string-equal token-type "atom")
  212.       (if (or (string-equal token ":-")
  213.               (string-equal token "?-"))
  214.           (progn 
  215.             (setq *functor* token)
  216.             (setq *arity* 1)
  217.             (forward-to-clause-end term-start)
  218.             (set-mark (point))
  219.             (goto-char term-start)
  220.             )
  221.         (progn 
  222.           (setq *functor* token)
  223.           (setq *arity* 0)
  224.           (setq *arity* 
  225.                 (+ *arity* (arity-overhead-for-grammar-rule term-start)))
  226.           (set-mark (point))
  227.           (goto-char term-start)
  228.           )
  229.         )
  230.       )
  231.      ((string-equal token-type "functor")
  232.       (setq *functor* token)
  233.       (setq *arity* (all-arity term-start))
  234.       (set-mark (point))
  235.       (goto-char term-start)
  236.       )
  237.       ((string-equal token-type "eof")
  238.        (setq *functor* "end_of_file")
  239.        (setq *arity* -1)
  240.        (set-mark (point))
  241.        (goto-char term-start)
  242.        )
  243.       (t (BadFind "Wrong term type to start clause, command, or query"))
  244.       )
  245.     )
  246. )
  247.  
  248. (defun BadArity (message)
  249.   (error message)
  250. )
  251.  
  252. (defun all-arity (term-start)
  253.   (let ((temp-arity (head-arity)))
  254.     (+ temp-arity (arity-overhead-for-grammar-rule term-start))
  255.   )
  256. )
  257.  
  258. ; 
  259. ; This function assumes that you are looking at the left parenthesis
  260. ; immediately following the atom of a complex predicate.  It knows that
  261. ; it's looking at the parenthesis because the tokenizer looks ahead to
  262. ; it, '(', to determine that it is just read a "functor" instead of just an 
  263. ; "atom".
  264. ;        foo(X,Y) ...
  265. ;           ^
  266. ; 
  267.  
  268. (defun head-arity ()
  269.   (let  ((state 0)
  270.          (stack)
  271.          (arity 1)
  272.          token-type
  273.          token
  274.          (original-dot (dot)))
  275.  
  276.     (if (= (following-char) ?\( )
  277.     (forward-char)
  278.       (BadArity "Can't start calculating arity at this point")
  279.       )
  280.  
  281.     (while (not (= state 2))
  282.       (setq token-type (next-token))
  283.       (setq token (region-to-string))
  284.  
  285.       (if (or (string-equal token-type "stop")
  286.               (string-equal token-type "eof")
  287.               )
  288.           (progn 
  289.             (goto-char original-dot)
  290.             (BadArity "Unclosed parenthesis.")
  291.             )
  292.         )
  293.       (cond 
  294.        ((= state 0)
  295.         (cond
  296.          ((string-equal token "(")
  297.           (progn 
  298.             (setq stack (cons ")" stack))
  299.             (setq state 1)
  300.             ))
  301.          ((string-equal token "[")
  302.           (progn 
  303.             (setq stack (cons "]" stack))
  304.             (setq state 1)
  305.             ))
  306.          ((string-equal token "{")
  307.           (progn 
  308.             (setq stack (cons "}" stack))
  309.             (setq state 1)
  310.             ))
  311.          ((string-equal token ")")
  312.           (setq state 2))
  313.          ((or (string-equal token "]") (string-equal token "}"))
  314.           (BadArity "Mismatched parentheses."))
  315.          ((string-equal token ",")
  316.           (setq arity (+ arity 1)))
  317.      ))
  318.        ((= state 1)
  319.         (cond
  320.          ((string-equal token "(") (setq stack (cons ")" stack)))
  321.          ((string-equal token "[") (setq stack (cons "]" stack)))
  322.          ((string-equal token "{") (setq stack (cons "}" stack)))
  323.          ((or 
  324.            (string-equal token ")") 
  325.            (string-equal token "]") 
  326.            (string-equal token "}"))
  327.           (if (not (string-equal (car stack) token))
  328.               (BadArity "Mismatched parentheses.")
  329.             )
  330.           (setq stack (cdr stack))
  331.           (if (null stack)
  332.               (setq state 0)
  333.             )
  334.           )
  335.      )
  336.         )
  337.        )
  338.       )
  339.     arity
  340.     )
  341.   )
  342.  
  343. (defun within-comment ()
  344.   (let ((original-dot (dot)) (return))
  345.     (if (not (re-search-backward "/\\*\\|\\*/" nil t)) ; '/*' or '*/'
  346.         (setq return nil)
  347.         (if (= (following-char) ?*)      ; found '*/'
  348.             (progn 
  349.               (goto-char original-dot)
  350.               (setq return nil)
  351.               )
  352.           (progn
  353.             (goto-char original-dot)
  354.             (setq return (search-forward "*/" nil t))
  355.             (goto-char original-dot)
  356.             )
  357.           )
  358.       )
  359.     return
  360.     )
  361. )
  362.